perm filename MACHIN.LSP[BOO,JMC] blob
sn#484095 filedate 1979-10-20 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00006 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 (DEFPROP MACHIN
C00006 00003 (DEFPROP EDITOR (
C00011 00004 ATOMIC-EDIT-FNS
C00016 00005 LIST-EDIT-FNS
C00018 00006 (DEFUN !TRACE (FN)
C00021 ENDMK
C⊗;
(DEFPROP MACHIN
((READB U)
(READA U L)
(PRINDOT E)
(PRINA E L)
(PRINLIS E)
(PRINB E L)
(REV1 U V)
(READ U)
(READS U)
(READT U L)
(READ_TESTS)
) READ_PGMS)
(DEFUN READB (U)
(COND ((EQ (CAR U) 'LP) (CAR (READA (CDR U) NIL)))
(T (CAR U))))
(DEFUN READA (U L)
(COND ((NULL U) (CONS (REV1 L 'ERROR) NIL))
((EQ (CAR U) 'RP) (CONS (REVERSE L) (CDR U)))
((EQ (CAR U) 'LP)
((LAMBDA (W) (READA (CDR W) (CONS (CAR W) L)))
(READA (CDR U) NIL)))
((EQ (CAR U) 'DOT)
((LAMBDA (W) (CONS (REV1 L (CAAR W)) (CDR W)))
(READA (CDR U) NIL)))
(T (READA (CDR U) (CONS (CAR U) L)))))
(DEFUN PRINDOT (E) (PRINA E NIL))
(DEFUN PRINA (E L)
(COND ((ATOM E) (CONS E L))
(T (CONS 'LP
(PRINA (CAR E)
(CONS 'DOT
(PRINA (CDR E)
(CONS 'RP L))))))))
(DEFUN PRINLIS (E) (PRINB E NIL))
(DEFUN PRINB (E L)
(COND ((ATOM E) (CONS E L))
(T (CONS 'LP
(COND ((NULL (CDR E))
(PRINB (CAR E) (CONS 'RP L)))
((ATOM (CDR E))
(PRINB (CAR E)
(CONS 'DOT
(CONS (CDR E)
(CONS 'RP
L)))))
(T (PRINB (CAR E)
(CDR (PRINB (CDR E) L)))))))))
(DEFUN REV1 (U V)
(COND ((NULL U) V) (T (REV1 (CDR U) (CONS (CAR U) V)))))
(DEFUN READ (U)
((LAMBDA (R)
(COND ((ATOM R) (LIST 'NOT-WELL-FORMED R U))
((NOT (NULL (CDR R))) (LIST 'NOT-WELL-FORMED R U))
(T (CAR R))))
(READS U)))
(DEFUN READS (U) (COND ((EQUAL (CAR U) 'LP) (READT (CDR U) NIL)) (T U)) )
(DEFUN READT (U L)
(COND ((NULL U) 'ERROR-UNBALANCED)
((EQ (CAR U) 'RP) (CONS (REV1 L NIL) (CDR U)))
((EQ (CAR U) 'DOT)
((LAMBDA (W) (CONS (REV1 L (CAAR W)) (CDR W)))(READT (CDR U) NIL)) )
(T
((LAMBDA (W) (READT (CDR W) (CONS (CAR W) L)))(READS U)) ) ))
(DEFUN READ_TESTS ()
(PROG ()
(SETQ S1 '(A))
(SETQ S2 '(LP RP))
(SETQ S3 '(LP A RP))
(SETQ S4 '(LP A DOT B RP))
(SETQ S5 '(LP A A DOT B RP))
(SETQ S6 '(LP LP A RP A DOT B RP))
))
(DEFPROP EDITOR (
EDITOR
ERRMSG0
ERRMSG1
ERRMSG2
ERRMSG3
ERRMSG4
ERRMSG5
ERRMSG6
NTH
POS
COPY
CHOP
) EDITORFNS)
(DEFPROP EDITOR
'(|TOP: CE ← TOP|
|UP: CE ← PARENT(CE)|
|LF: MOVE LEFT|
|RT: MOVE RIGHT|
|RI: MOVE RIGHT PAREN IN |
|RO: MOVE RIGHT PAREN OUT |
|LI: MOVE LEFT PAREN IN |
|LO: MOVE LEFT PAREN OUT |
| P: PRINT THE CE |
| B: BREAK |
|(I N X):Insert X before Nth element |
|(D N): Delete Nth element |
) EDIT-COMMAND-DOC )
(DEFUN EDITOR FEXPR (L)
(PROG (FN TOP CE CHAIN COMMAND EFN)
(SETQ FN (CAR L))
(SETQ TOP (COPY (GET FN 'EXPR)))
(COND ((NULL TOP) (ERRMSG0) (RETURN 'NO-EDIT)))
(SETQ CE TOP CHAIN NIL)
EDLOOP
(PRINT 'ε)
(SETQ COMMAND (READ))
(COND ((EQ COMMAND 'Q) (RETURN 'BYE) )
((EQ COMMAND 'OK) (RETURN (PUTPROP FN TOP 'EXPR)) )
((NUMBERP COMMAND)
(COND ((OR (ATOM CE) (GREATERP COMMAND (LENGTH CE)))
(ERRMSG1) (GO EDLOOP)))
(SETQ CHAIN (CONS (CONS COMMAND CE) CHAIN))
(SETQ CE (NTH CE COMMAND))
(GO EDLOOP) ) )
(COND ((ATOM COMMAND) (SETQ EFN (GET COMMAND 'ATOMIC-EDIT-FN)))
(T (SETQ EFN (GET (CAR COMMAND) 'LIST-EDIT-FN))) )
(COND ((EQ EFN NIL)(PRINT (EVAL COMMAND)) (GO EDLOOP))
((ATOM COMMAND) (EVAL EFN) (GO EDLOOP) )
((NOT (ATOM COMMAND)) (APPLY EFN (CDR COMMAND)) (GO EDLOOP)) )
))
;;; AUXILIARY EDIT FNS
(DEFUN ERRMSG0 () (PRINT FN) (PRINC '| not an EXPR |))
(DEFUN ERRMSG1 () (PRINT COMMAND) (PRINC '| > length of CE |))
(DEFUN ERRMSG2 () (TERPRI) (PRINC '| Unknown command |))
(DEFUN ERRMSG3 () (TERPRI) (PRINC '| You are at the top |))
(DEFUN ERRMSG4 () (TERPRI) (PRINC '| You are at the left edge |))
(DEFUN ERRMSG5 () (TERPRI) (PRINC '| You are at the right edge |))
(DEFUN ERRMSG6 () (TERPRI) (PRINC '| CE is atomic |))
(DEFUN NTH (U N)
(COND ((AND (GREATERP N 1) (NOT (NULL (CDR U)))) (NTH (CDR U) (SUB1 N)))
(T (CAR U)) ))
(DEFUN POS (U N)
(COND ((AND (GREATERP N 1) (NOT (NULL (CDR U)))) (POS (CDR U) (SUB1 N)))
(T U) ))
(DEFUN COPY (X) (COND ((ATOM X) X) (T (CONS (COPY (CAR X)) (COPY (CDR X)))) ))
(DEFUN CHOP (U)
(PROG (U1 U2)
(SETQ U1 U)
LOOP
(SETQ U2 (CDR U1))
(COND ((NULL (CDR U2)) (RPLACD U1 NIL) (RETURN (CAR U2))))
(SETQ U1 U2)
(GO LOOP) ))
(DEFUN PRINTCOMMANDS (CL)
(PROG ()
PRINTLOOP
(COND ((NULL CL) (RETURN NIL)) )
(PRINC '| |)
(PRINC (CAR CL))
(TERPRI)
(SETQ CL (CDR CL))
(GO PRINTLOOP)
))
;;; ATOMIC-EDIT-FNS
(DEFPROP EDITOR (
TOP
UP
LF
RT
RI
RO
LI
RO
P
B
HELP
) ATOMIC-EDIT-FNS)
(DEFPROP TOP ;;;
(PROG ()
(SETQ CE TOP)
(SETQ CHAIN NIL))
ATOMIC-EDIT-FN)
(DEFPROP UP ;;;CE ← PARENT(CE)
(PROG ()
(COND ((NULL CHAIN) (RETURN (ERRMSG3))))
(SETQ CE (CDAR CHAIN))
(SETQ CHAIN (CDR CHAIN)) )
ATOMIC-EDIT-FN)
(DEFPROP LF ;;;MOVE LEFT
(PROG (N)
(COND ((NULL CHAIN) (RETURN (ERRMSG3))))
(SETQ N (SUB1 (CAAR CHAIN)))
(COND ((LESSP N 1) (RETURN (ERRMSG4))))
(SETQ CE (NTH (CDAR CHAIN) N))
(RPLACA (CAR CHAIN) N))
ATOMIC-EDIT-FN)
(DEFPROP RT ;;;MOVE RIGHT
(PROG (N)
(COND ((NULL CHAIN) (RETURN (ERRMSG3))))
(SETQ N (ADD1 (CAAR CHAIN)))
(COND ((GREATERP N (LENGTH (CDAR CHAIN))) (RETURN (ERRMSG5))))
(SETQ CE (NTH (CDAR CHAIN) N))
(RPLACA (CAR CHAIN) N))
ATOMIC-EDIT-FN)
(DEFPROP RI ;;;MOVE RIGHT PAREN IN
(PROG (CETMP POS)
(COND ((NULL CHAIN) (RETURN (ERRMSG3))))
(COND ((ATOM CE) (RETURN (ERRMSG6))))
(SETQ CETMP (CONS NIL CE))
(SETQ POS (POS (CDAR CHAIN) (CAAR CHAIN)))
(RPLACD POS (CONS (CHOP CETMP) (CDR POS)))
(RPLACA POS (SETQ CE (CDR CETMP))) );;; IN CASE CE CHOPPED TO NIL
ATOMIC-EDIT-FN)
(DEFPROP RO ;;;MOVE RIGHT PAREN OUT
(PROG (CETMP POS POS1)
(COND ((NULL CHAIN) (RETURN (ERRMSG3))))
(COND ((AND (ATOM CE) (NOT (NULL CE))) (RETURN (ERRMSG6))))
(SETQ POS (POS (CDAR CHAIN) (CAAR CHAIN)))
(SETQ POS1 (CDR POS))
(COND ((NULL POS1) (RETURN (ERRMSG5))))
(SETQ CETMP (CONS NIL CE))
(NCONC CETMP POS1) ;;;MOVE RT(CE) TO END OF CE
(RPLACD POS (CDR POS1))
(RPLACD POS1 NIL)
(RPLACA POS (SETQ CE (CDR CETMP))) ) ;;; IN CASE CE WAS NIL
ATOMIC-EDIT-FN)
(DEFPROP LI ;;;MOVE LEFT PAREN IN
(PROG (CETMP POS)
(COND ((NULL CHAIN) (RETURN (ERRMSG3))))
(COND ((ATOM CE) (RETURN (ERRMSG6))))
(SETQ POS (POS (CDAR CHAIN) (CAAR CHAIN)))
(RPLACD POS (CONS (CDR CE) (CDR POS)))
(RPLACA POS (CAR CE))
(SETQ CE (CDR CE))
(RPLACA (CAR CHAIN) (ADD1 (CAAR CHAIN))) )
ATOMIC-EDIT-FN)
(DEFPROP LO ;;;MOVE LEFT PAREN OUT
(PROG (CETMP POS)
(COND ((NULL CHAIN) (RETURN (ERRMSG3))))
(COND ((AND (ATOM CE) (NOT (NULL CE))) (RETURN (ERRMSG6))))
(SETQ N (SUB1 (CAAR CHAIN)))
(COND ((LESSP N 1) (RETURN (ERRMSG4))))
(SETQ POS (POS (CDAR CHAIN) N))
(RPLACD POS (CDDR POS))
(RPLACA POS (CONS (CAR POS) CE))
(RPLACA (CAR CHAIN) N)
(SETQ CE (CAR POS)) )
ATOMIC-EDIT-FN)
(DEFPROP P ;;;PRINT THE CE
(PRINT CE)
ATOMIC-EDIT-FN)
(DEFPROP B ;;;BREAK
(BREAK EDITOR T)
ATOMIC-EDIT-FN)
(DEFPROP HELP ;;;
(PROG (L)
(SETQ L (GET 'EDITOR 'EDIT-COMMAND-DOC))
(PRINT '|The following editor commands are implemented:|)
(PRINTCOMMANDS L)
)
ATOMIC-EDIT-FN)
;;; LIST-EDIT-FNS
(DEFPROP EDITOR (
(I N X)
(D N)
) LIST-EDIT-FNS)
(DEFPROP I
(LAMBDA (N X)
(PROG (POS TMP)
(COND ((LESSP N 0) (RETURN (ERRMSG2)))
((EQ N 1) ;;; RESET CE AND POINTERS TO IT
(COND ((NULL CHAIN)(SETQ TOP (SETQ CE (CONS X CE))))
(T (RPLACA (POS (CDAR CHAIN) (CAAR CHAIN))
(SETQ CE (CONS X CE)))))))
(SETQ POS (POS CE (SUB1 N)))
(SETQ TMP (CONS X NIL))
(RPLACD TMP (CDR POS))
(RPLACD POS TMP)))
LIST-EDIT-FN)
(DEFPROP D
(LAMBDA (N)
(PROG (POS TMP)
(COND ((LESSP N 0) (RETURN (ERRMSG2)))
((EQ N 1) ;;; RESET CE AND POINTERS TO IT
(COND ((NULL CHAIN)(SETQ TOP (SETQ CE (CDR CE))))
(T (RPLACA (POS (CDAR CHAIN) (CAAR CHAIN))
(SETQ CE (CDR CE))))))
((GREATERP N (LENGTH CE)) (RETURN (ERRMSG2))))
(SETQ POS (POS CE (SUB1 N)))
(RPLACD POS (CDDR POS)) ))
LIST-EDIT-FN)
(DEFUN !TRACE (FN)
(PROG (DEF)
(COND ((GET FN 'TRACED) (RETURN ('ALREADY-TRACED))) )
(SETQ DEF (GET FN 'EXPR))
(COND ((NULL DEF) (RETURN 'NOT-DEFINED)))
(COND ((NOT (EQ (CAR DEF) 'LAMBDA)) (RETURN 'NOT-LAMBDA)))
(PUTPROP FN T 'TRACED)
(PUTPROP FN DEF '!OLDDEF)
(PUTPROP FN
(SUBST FN '?FN
(SUBST (CADR DEF) '?ARGS
(SUBST (CONS 'LIST (CADR DEF)) '*ARGS (GET '!TRACE '!PATTERN)))) 'EXPR)
(RETURN 'OK)
))
(DEFUN !UNTRACE (FN)
(PROG (DEF)
(COND ((NOT (GET FN 'TRACED)) (RETURN 'NOT-TRACED)) )
(SETQ DEF (GET FN '!OLDDEF))
(PUTPROP FN NIL 'TRACED)
(REMPROP FN '!OLDDEF)
(PUTPROP FN DEF 'EXPR)
(RETURN 'OK)
))
(SETQ !ILEVEL 0)
(DEFPROP !TRACE
(LAMBDA ?ARGS
(PROG (!VAL)
(TERPRI)
(MARKS !ILEVEL)
(PRINC '|Entering |) (PRINC '?FN)
(PROG (ARGL)
(SETQ ARGL (QUOTE ?ARGS))
L1
(COND ((NULL ARGL) (RETURN NIL)))
(TERPRI)
(INDENT (PLUS !ILEVEL 2))
(PRINC (CAR ARGL)) (PRINC '| = |) (PRINC (EVAL (CAR ARGL)))
(SETQ ARGL (CDR ARGL))
(GO L1) )
(SETQ !VAL ((LAMBDA (!ILEVEL) (APPLY (GET '?FN '!OLDDEF) *ARGS)) (ADD1 !ILEVEL)) )
(TERPRI)
(INDENT !ILEVEL)
(PRINC '|Returning from |) (PRINC '?FN) (PRINC '| with |) (PRINC !VAL)
(TERPRI)
(RETURN !VAL)) )
!PATTERN)
(DEFUN INDENT (N)
(DO ((I 1 (ADD1 I)))((GREATERP I N) NIL) (PRINC '| |)) )
(DEFUN MARKS (N)
(DO ((I 1 (ADD1 I)))((GREATERP I N) NIL) (PRINC '|>|)) )